2.1 Main Analysis
First, we will calculate the average rating for each face separately for each of the 13 traits. Like Oosterhof and Todorov (2008), we will then subject these mean ratings to principal component analysis with orthogonal components and no rotation. Using the criteria reported in Oosterhof and Todorov’s (2008) paper, we will retain and interpret the components with an Eigenvalue > 1.
2.1.1 Calculate Alphas
# takes a long time, so saves the results and loads from a file in the next chunk if set to eval = FALSE
data_alpha <- data %>%
select(user_id, region, stim_id, rating, trait) %>%
spread(stim_id, rating, sep = "_") %>%
group_by(trait, region) %>%
nest() %>%
mutate(alpha = map(data, function(d) {
if (dim(d)[1] > 2) {
# calculate cronbach's alpha
subdata <- d %>%
as_tibble() %>%
select(-user_id) %>%
t()
capture.output(suppressWarnings(a <- psych::alpha(subdata)))
a$total["std.alpha"] %>% pluck(1) %>% round(3)
} else {
NA
}
})) %>%
select(-data) %>%
unnest(alpha) %>%
ungroup()
saveRDS(data_alpha, file = "data/alphas.RDS")data_alpha <- readRDS("data/alphas.RDS")
n_alpha <- data %>%
select(user_id, region, trait) %>%
distinct() %>%
count(region, trait) %>%
left_join(data_alpha, by = c("region", "trait")) %>%
mutate(
trait = as.factor(trait),
region = str_replace(region, " (and|&) ", " &\n"),
region = as.factor(region),
region = factor(region, levels = rev(levels(region)))
)
n_alpha %>%
mutate(stat = paste("α =", alpha, "<br>n =", n)) %>%
select(Region = region, stat, trait) %>%
spread(trait, stat) %>%
knitr::kable("html", escape = FALSE) %>%
column_spec(2:14, width = "7%") %>%
kable_styling("striped", font_size = 9) %>%
save_kable("figures/alpha.html")ggplot(n_alpha) +
geom_tile(aes(trait, region, fill=alpha >=.7),
color = "grey20", show.legend = F) +
geom_text(aes(trait, region, label=sprintf("α = %0.2f\nn = %.0f", alpha, n)), color = "black", size = 5) +
scale_y_discrete(drop=FALSE) +
scale_x_discrete(position = "top") +
labs(x="", y="", title="") +
scale_fill_manual(values = c("white", "red")) +
PSA_theme
ggsave("figures/alphas.png", width = 18, height = 10)2.1.2 Calculate Aggregate Scores
data_agg <- data %>%
group_by(region, trait, stim_id) %>%
summarise(rating = mean(rating)) %>%
ungroup() %>%
spread(trait, rating)
write_csv(data_agg, "data/psa001_agg_subset.csv")data_agg %>%
gather("trait", "rating", aggressive:weird) %>%
ggplot(aes(rating, fill = trait)) +
geom_density(show.legend = F) +
facet_grid(region~trait) +
PSA_theme
ggsave("figures/agg_scores.png", width = 15, height = 8)2.1.3 Principal Component Analysis (PCA)
The number of components to extract was determined using eigenvalues > 1 for each world region. PCA was conducted using the psych::principal() function with rotate="none".
# function to calculate PCA
psa_pca <- function(d) {
traits <- select(d, -stim_id) %>%
select_if(colSums(!is.na(.)) > 0) # omits missing traits
# principal components analysis (SPSS-style, following Oosterhof & Todorov)
ev <- eigen(cor(traits))$values
nfactors <- sum(ev > 1)
pca <- principal(
traits,
nfactors=nfactors,
rotate="none"
)
stats <- pca$Vaccounted %>%
as.data.frame() %>%
rownames_to_column() %>%
mutate(type = "stat")
unclass(pca$loadings) %>%
as.data.frame() %>%
rownames_to_column() %>%
mutate(type = "trait") %>%
bind_rows(stats) %>%
gather("pc", "loading", 2:(ncol(.)-1))
}pca_analyses <- data_agg %>%
bind_rows(ot_data) %>%
group_by(region) %>%
nest() %>%
mutate(pca = map(data, psa_pca)) %>%
select(-data) %>%
unnest(pca) %>%
ungroup() %>%
mutate(pc = str_replace(pc, "PC", "Component "))2.1.3.1 Number of Components (and proportion variance) by region
pca_analyses %>%
filter(rowname == "Proportion Var") %>%
group_by(region) %>%
mutate(nPCs = n()) %>%
ungroup() %>%
spread(pc, loading) %>%
select(-rowname, -type) %>%
mutate_if(is.numeric, round, 3) %>%
knitr::kable("html") %>%
kable_styling("striped")| region | nPCs | Component 1 | Component 2 | Component 3 |
|---|---|---|---|---|
| (Oosterhof & Todorov, 2008) | 2 | 0.633 | 0.183 | |
| Africa | 2 | 0.423 | 0.126 | |
| Asia | 3 | 0.581 | 0.168 | 0.084 |
| Australia & New Zealand | 3 | 0.580 | 0.167 | 0.094 |
| Central America & Mexico | 3 | 0.452 | 0.191 | 0.079 |
| Eastern Europe | 3 | 0.568 | 0.176 | 0.083 |
| Middle East | 3 | 0.428 | 0.230 | 0.090 |
| Scandinavia | 3 | 0.576 | 0.167 | 0.079 |
| South America | 2 | 0.535 | 0.219 | |
| UK | 3 | 0.499 | 0.163 | 0.110 |
| USA & Canada | 3 | 0.634 | 0.182 | 0.084 |
| Western Europe | 2 | 0.636 | 0.180 |
2.1.3.2 Trait Loadings by Region and Component
# order traits by P1 loading if loads positively on P1, or by -P2 loading otherwise
trait_order <- pca_analyses %>%
filter(region == "(Oosterhof & Todorov, 2008)", type == "trait") %>%
spread(pc, loading) %>%
arrange(ifelse(`Component 1`>0,`Component 1`,-`Component 2`)) %>%
pull(rowname)
pca_prop_var <- pca_analyses %>%
filter(rowname == "Proportion Var") %>%
select(-rowname, -type) %>%
mutate(loading = round(loading, 2))
pca_analyses %>%
filter(type == "trait") %>%
select(-type) %>%
mutate(
trait = as.factor(rowname),
trait = factor(trait, levels = c(trait_order, "Prop.Var")),
loading = round(loading, 2)
) %>%
ggplot() +
geom_tile(aes(pc, trait, fill=loading), show.legend = F) +
geom_text(aes(pc, trait, label=sprintf("%0.2f", loading)), color = "black") +
geom_text(data = pca_prop_var, aes(pc, y = 14, label=sprintf("%0.2f", loading)), color = "black") +
scale_y_discrete(drop=FALSE) +
scale_x_discrete(position = "top") +
scale_fill_gradient2(low = "dodgerblue", mid = "grey90", high = "#FF3333", limits=c(-1.1, 1.1)) +
facet_wrap(~region, scales = "fixed", ncol = 4) +
labs(x = "", y = "", title="") +
PSA_theme
ggsave("figures/PCA_loadings.png", width = 15, height = 10)2.1.3.3 Replication Criteria (PCA)
Oosterhof and Todorov’s valence-dominance model will be judged to have been replicated in a given world region if the first two components both have Eigenvalues > 1, the first component (i.e., the one explaining more of the variance in ratings) is correlated strongly (loading > .7) with trustworthiness and weakly (loading < .5) with dominance, and the second component (i.e., the one explaining less of the variance in ratings) is correlated strongly (loading > .7) with dominance and weakly (loading < .5) with trustworthiness. All three criteria need to be met to conclude that the model was replicated in a given world region.
pca_rep <- pca_analyses %>%
filter(
type == "trait",
rowname %in% c("trustworthy", "dominant"),
pc %in% c("Component 1", "Component 2")
) %>%
select(-type) %>%
mutate(rowname = paste(pc, rowname)) %>%
select(-pc) %>%
spread(rowname, loading) %>%
rename(Region = region) %>%
mutate(Replicated = ifelse(
`Component 1 dominant` < .5 & `Component 1 trustworthy` > .7 &
`Component 2 dominant` > .7 & `Component 2 trustworthy` < .5,
"Yes", "No"
)) %>%
mutate_if(is.numeric, round, 3) %>%
knitr::kable("html", col.names = c("Region", "Dominant", "Trustworthy", "Dominant", "Trustworthy", "Replicated")) %>%
add_header_above(c(" " = 1, "Component 1" = 2, "Component 2" = 2, " " = 1)) %>%
kable_styling("striped")
save_kable(pca_rep, "figures/PCA_rep_criteria.html")
pca_rep| Region | Dominant | Trustworthy | Dominant | Trustworthy | Replicated |
|---|---|---|---|---|---|
| (Oosterhof & Todorov, 2008) | -0.244 | 0.941 | 0.929 | -0.060 | Yes |
| Africa | 0.202 | 0.847 | 0.660 | -0.101 | No |
| Asia | 0.300 | 0.884 | 0.855 | -0.027 | Yes |
| Australia & New Zealand | 0.172 | 0.921 | 0.903 | -0.092 | Yes |
| Central America & Mexico | 0.111 | 0.808 | 0.871 | -0.071 | Yes |
| Eastern Europe | 0.437 | 0.842 | 0.788 | -0.117 | Yes |
| Middle East | 0.335 | 0.695 | 0.749 | -0.323 | No |
| Scandinavia | 0.426 | 0.937 | 0.836 | -0.120 | Yes |
| South America | 0.150 | 0.866 | 0.940 | -0.247 | Yes |
| UK | 0.493 | 0.858 | 0.716 | -0.045 | Yes |
| USA & Canada | 0.382 | 0.952 | 0.826 | -0.096 | Yes |
| Western Europe | 0.379 | 0.930 | 0.866 | -0.192 | Yes |
2.1.4 Factor Congruence (PCA)
This analysis determines the congruence between the components from Oosterhof & Todorov (2008) and the components in each world region, using the psych::factor.congruence function. Congruence is labeled “not similar” for values < 0.85, “fairly similar”, for values < 0.09, and “equal” for values >= 0.95.
# get loadings for original O&T2008
ot2008_pca_loadings <- pca_analyses %>%
filter(region == "(Oosterhof & Todorov, 2008)", type == "trait") %>%
select(-region, -type) %>%
spread(pc, loading) %>%
column_to_rownames()
# run factor congruence for each region
fc_pca <- pca_analyses %>%
filter(type == "trait", region != "(Oosterhof & Todorov, 2008)") %>%
select(-type) %>%
spread(pc, loading) %>%
group_by(region) %>%
nest() %>%
mutate(fc = map(data, function(d) {
loadings <- d %>%
as.data.frame() %>%
select(rowname, `Component 1`, `Component 2`) %>%
arrange(rowname) %>%
column_to_rownames()
psych::factor.congruence(loadings,
ot2008_pca_loadings,
digits = 4) %>%
as.data.frame() %>%
rownames_to_column(var = "regionPC")
})) %>%
select(-data) %>%
unnest(fc) %>%
ungroup()
pc_fc_table <- fc_pca %>%
gather(origPC, congruence, `Component 1`:`Component 2`) %>%
mutate(sig = case_when(
congruence < .85 ~ "not similar",
congruence < .95 ~ "fairly similar",
congruence >= .95 ~ "equal"
),
congruence = sprintf("%0.3f", congruence)) %>%
filter(regionPC == origPC) %>%
select(region, PC = regionPC, congruence, sig) %>%
gather(k, v, congruence, sig) %>%
unite(PC, PC, k, remove = T) %>%
spread(PC, v) %>%
knitr::kable("html", digits = 3, align = 'lrlrl', escape = F,
col.names = c("Region", "Loading", "Congruence", "Loading", "Congruence")) %>%
add_header_above(c(" " = 1, "Component 1" = 2, "Component 2" = 2)) %>%
kable_styling("striped")
save_kable(pc_fc_table, "figures/PCA_factor_congruence.html")
pc_fc_table| Region | Loading | Congruence | Loading | Congruence |
|---|---|---|---|---|
| Africa | 0.964 | equal | 0.891 | fairly similar |
| Asia | 0.977 | equal | 0.836 | not similar |
| Australia & New Zealand | 0.985 | equal | 0.966 | equal |
| Central America & Mexico | 0.988 | equal | 0.915 | fairly similar |
| Eastern Europe | 0.964 | equal | 0.960 | equal |
| Middle East | 0.951 | equal | 0.836 | not similar |
| Scandinavia | 0.966 | equal | 0.947 | fairly similar |
| South America | 0.985 | equal | 0.952 | equal |
| UK | 0.948 | fairly similar | 0.929 | fairly similar |
| USA & Canada | 0.973 | equal | 0.953 | equal |
| Western Europe | 0.973 | equal | 0.939 | fairly similar |
